home *** CD-ROM | disk | FTP | other *** search
/ HPAVC / HPAVC CD-ROM.iso / pc / BPC-DE10.ZIP / SENDANSI.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1995-09-05  |  4.7 KB  |  203 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Turbo Pascal Version 7.0                        }
  5. {       ANSI Output Unit                                }
  6. {                                                       }
  7. {       Copyright (c) 1994,95 by Solar Designer         }
  8. {                                                       }
  9. {*******************************************************}
  10.  
  11. unit SendANSI;
  12. {$B-,G+}
  13. interface
  14.  
  15. const
  16.    ScreenAddr      :Pointer= Ptr($B800, 0);
  17.    ScreenWidth     :Word =   80;
  18.    SendWidth       :Word =   80;
  19.    SendHeight      :Word =   24;
  20.  
  21.    ScreenSize      :Word =   0;
  22.    SavedScreen     :Pointer= nil;
  23.  
  24.    MaxSendTime =   9;
  25.  
  26.    SendCharANSI    :Procedure (c       :Char) =  nil;
  27.    CDANSI          :Function           :Boolean= nil;
  28.  
  29. procedure InitSendANSI;
  30.  
  31. procedure DoneSendANSI;
  32.  
  33. procedure UpdateSendANSI;
  34.  
  35. implementation
  36.  
  37. type
  38.    TByteArray =    Array [0..32767] of Byte;
  39.    PByteArray =    ^TByteArray;
  40.  
  41. procedure SendString(const s           :String);
  42. var
  43.    i               :Integer;
  44. begin
  45.    if @SendCharANSI<>nil then
  46.    for i:=1 to Length(s) do SendCharANSI(s[i]);
  47. end;
  48.  
  49. procedure SendXY(x, y                  :Integer);
  50. var
  51.    Buf1, Buf2      :String[3];
  52. begin
  53.    Str(y+1, Buf1); Str(x+1, Buf2);
  54.    SendString(#27'['+Buf1+';'+Buf2+'H');
  55. end;
  56.  
  57. procedure SendAttr(Attr                :Byte);
  58. var
  59.    Buf1            :Char;
  60.    Buf2, Buf3      :String[3];
  61. const
  62.    Colors          :Array [0..7] of Byte =
  63.    (0, 4, 2, 6, 1, 5, 3, 7);
  64. begin
  65.    if Attr=$07 then SendString(#27'[0m') else
  66.    begin
  67.       if Attr and $80<>0 then Buf1:='5' else
  68.       if Attr and $08<>0 then Buf1:='1' else Buf1:='0';
  69.       Str(30+Colors[Attr and $07], Buf2);
  70.       Str(40+Colors[(Attr and $70) shr 4], Buf3);
  71.       SendString(#27'['+Buf1+';'+Buf2+';'+Buf3+'m');
  72.    end;
  73. end;
  74.  
  75. procedure SendClear;
  76. begin
  77.    SendString(#27'[2J');
  78. end;
  79.  
  80. procedure InitSendANSI;
  81. begin
  82.    DoneSendANSI;
  83.    ScreenSize:=ScreenWidth*SendHeight shl 1;
  84.    if ScreenSize>MaxAvail then
  85.    begin
  86.       ScreenSize:=0; Exit;
  87.    end;
  88.    GetMem(SavedScreen, ScreenSize);
  89.    FillChar(SavedScreen^, ScreenSize, 0);
  90.  
  91.    SendClear;
  92. end;
  93.  
  94. procedure DoneSendANSI;
  95. begin
  96.    if ScreenSize<>0 then
  97.    begin
  98.       FreeMem(SavedScreen, ScreenSize); ScreenSize:=0;
  99.       SendAttr($07); SendClear;
  100.    end;
  101. end;
  102.  
  103. function  GetChar(s                    :Pointer;
  104.                   x, y                 :Integer) :Char;
  105. assembler;
  106. asm
  107.    mov  ax,y
  108.    mul  ScreenWidth
  109.    add  ax,x
  110.    add  ax,ax
  111.    mov  bx,ax
  112.    les  di,s
  113.    mov  al,es:[di+bx]
  114. end;
  115.  
  116. function  GetAttr(s                    :Pointer;
  117.                   x, y                 :Integer) :Byte;
  118. assembler;
  119. asm
  120.    inc  word ptr s
  121.    leave
  122.    jmp  GetChar
  123. end;
  124.  
  125. procedure MoveChar(Src, Dst            :Pointer;
  126.                    x, y                :Integer);
  127. assembler;
  128. asm
  129.    push ds
  130.    mov  ax,y
  131.    mul  ScreenWidth
  132.    add  ax,x
  133.    add  ax,ax
  134.    lds  si,Src
  135.    les  di,Dst
  136.    add  si,ax
  137.    add  di,ax
  138.    movsw
  139.    pop  ds
  140. end;
  141.  
  142. procedure UpdateSendANSI;
  143. var
  144.    x, y,
  145.    cx, cy, ca,
  146.    cp              :Integer;
  147.    CShp            :Byte;
  148.    CpChg           :Boolean;
  149.    c               :Char;
  150.    Timer           :Word absolute 0:$46C;
  151.    LTimer          :Word;
  152. const
  153.    Lcp   :Integer= -1;
  154.    LCShp :Byte=    $FF;
  155. begin
  156.    if (ScreenSize=0) or not Assigned(SendCharANSI) or not Assigned(CDANSI) then Exit;
  157.  
  158.    cx:=-1; cy:=-1; ca:=-1; CpChg:=False;
  159.  
  160.    asm
  161.       mov  ah,03h
  162.       xor  bx,bx
  163.       int  10h
  164.       mov  cp,dx
  165.       mov  CShp,ch
  166.    end;
  167.  
  168.    LTimer:=Timer;
  169.    for y:=0 to SendHeight-1 do
  170.    begin
  171.       for x:=0 to SendWidth-1 do
  172.       if ((GetChar(ScreenAddr, x, y)<>GetChar(SavedScreen, x, y)) or
  173.          (GetAttr(ScreenAddr, x, y)<>GetAttr(SavedScreen, x, y))) and
  174.          ((y<>SendHeight-1) or (x<>SendWidth-1)) then
  175.       begin
  176.          if (x<>cx) or (y<>cy) then SendXY(x, y);
  177.          if GetAttr(ScreenAddr, x, y)<>ca then SendAttr(GetAttr(ScreenAddr, x, y));
  178.          c:=GetChar(ScreenAddr, x, y);
  179.          case c of
  180.             #16, #26: c:='>';
  181.             #17, #27: c:='<';
  182.             #0, #255: c:=' ';
  183.          end;
  184.          SendCharANSI(c);
  185.          ca:=GetAttr(ScreenAddr, x, y);
  186.          cx:=x+1; cy:=y; if cx>=SendWidth then cx:=-1;
  187.          CpChg:=True;
  188.  
  189.          MoveChar(ScreenAddr, SavedScreen, x, y);
  190.  
  191.          if not CDANSI then Exit;
  192.       end;
  193.  
  194.       if (Timer<LTimer) or (Timer-LTimer>MaxSendTime) then Break;
  195.    end;
  196.  
  197.    if (cp<>Lcp) or (CShp<>LCShp) or CpChg then
  198.    if CShp=$20 then SendXY(0, 0) else SendXY(Lo(cp), Hi(cp));
  199.    Lcp:=cp; LCShp:=CShp;
  200. end;
  201.  
  202. end.
  203.